home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
PROGASIC
/
BASFILES.LZH
/
HNUMINPT.BAS
< prev
next >
Wrap
BASIC Source File
|
1988-09-10
|
4KB
|
209 lines
'$INCLUDE:'QBTOOLS.INC'
'' '$INCLUDE: 'qbtools2.inc'
'CLS
'NumericInput 1, 1, 1, 1, 1, 1, 1, 10, 1, 10000, 55, St$, Nv#, 5, 5, 7, 0, Ek%
SUB hNumericInput (hB AS hBuffer, Allowup%, Allowpu%, Allowdn%, Allowpd%, Allowrt%, Allowtb%, Allowes%, il%, yd%, MaxV#, MinV#, St$, Nv#, Xc%, Yc%, fc%, Bc%, Ek%) STATIC
IF Nv# <> 0# THEN
St$ = STR$(Nv#)
Trim St$
END IF
Insert% = 0 ' Insert flag
IF LEN(St$) > il% THEN ' String is already too long
St$ = MID$(St$, 1, il%) ' Make it the right size
END IF
IF LEN(St$) < il% THEN ' MUST make it equal to BLANKS
St$ = St$ + STRING$(il% - LEN(St$), 32)
END IF
Xoff% = 1 ' X-co-ordinate offset
tmp$ = "" ' Erase it
Attr% = Attributes%(fc%, Bc%, 0, 0)
Ek% = 0
ColorPrint St$, Yc%, Xc%, Attr%
WHILE Ek% = 0 ' Until there's an exit
IF Xoff% > il% THEN ' Cursor positioner too long
Xoff% = il%
END IF
IF INSTR(St$, " ") > 0 THEN
IF Xoff% > (INSTR(St$, " ")) THEN
Xoff% = INSTR(St$, " ")
END IF
END IF
IF Xoff% < 1 THEN
Xoff% = 1
END IF
IF LEN(St$) < il% THEN ' MUST make it equal to BLANKS
St$ = St$ + STRING$(il% - LEN(St$), 32)
END IF
ColorPrint St$, Yc%, Xc%, Attr%
IF Insert% = 1 THEN ' Insert is on
LOCATE Yc%, Xc% + Xoff% - 1, 1, 0, 15
ELSE
LOCATE Yc%, Xc% + Xoff% - 1, 1, 7, 7
END IF
w$ = "" ' Wait until there's a character
WHILE w$ = ""
w$ = INKEY$
WEND
LOCATE , , 0
IF LEN(w$) = 1 THEN ' Normal character
ch% = ASC(w$)
IF yd% = 0 THEN
IF ch% = 46 THEN
ch% = 0
END IF
ELSE
IF ch% = 46 THEN
IF INSTR(St$, ".") > 0 THEN
ch% = 0
END IF
END IF
END IF
SELECT CASE ch%
CASE 46, 48 TO 57 ' Normal numeric value
IF Insert% = 1 THEN
IF Xoff% = 1 THEN
St$ = CHR$(ch%) + MID$(St$, 1, il% - 1)
ELSE
IF Xoff% = il% THEN
MID$(St$, il%, 1) = CHR$(ch%)
ELSE
St$ = MID$(St$, 1, Xoff% - 1) + CHR$(ch%) + MID$(St$, Xoff%)
St$ = LEFT$(St$, LEN(St$) - 1)
END IF
END IF
ELSE
MID$(St$, Xoff%, 1) = CHR$(ch%)
END IF
Xoff% = Xoff% + 1
CASE 8, 127 ' Back space
IF Xoff% > 1 THEN
IF Xoff% = il% THEN
MID$(St$, Xoff%, 1) = " "
MID$(St$, Xoff% - 1, 1) = " "
ELSE
MID$(St$, Xoff% - 1, 1) = " "
END IF
Xoff% = Xoff% - 1
END IF
CASE 13
IF Allowrt% = 1 THEN ' Yes, return is ok
Ek% = 5
END IF
CASE 9
IF Allowtb% = 1 THEN ' Yes, TAB is ok
Ek% = 6
END IF
CASE 27
IF Allowes% = 1 THEN ' Yes, ESC is ok
Ek% = 7
END IF
CASE ELSE
END SELECT
ELSE
ch% = ASC(MID$(w$, 2)) ' Extended character
SELECT CASE ch%
CASE 59, 84, 94, 104 ' Function key 1
hFrameHandler hB
CASE 75 ' Left arrow
Xoff% = Xoff% - 1
CASE 77 ' Right arrow
Xoff% = Xoff% + 1
CASE 71 ' Home
Xoff% = 0
CASE 79 ' End
Xoff% = il%
CASE 82 ' Insert
Insert% = 1 - Insert%
CASE 83 ' Delete
IF Xoff% = il% THEN
MID$(St$, il%, 1) = " "
ELSE
IF Xoff% = 1 THEN
St$ = MID$(St$, 2) + " "
ELSE
St$ = MID$(St$, 1, Xoff% - 1) + MID$(St$, Xoff% + 1) + " "
END IF
END IF
CASE 72 ' Up arrow
IF Allowup% = 1 THEN ' Yes, UP is ok
Ek% = 1
END IF
CASE 73 ' Page up
IF Allowpu% = 1 THEN ' Yes, PAGE UP is ok
Ek% = 2
END IF
CASE 81 ' Page down
IF Allowpd% = 1 THEN ' Yes, PAGE DOWN is ok
Ek% = 4
END IF
CASE 80 ' Down arrow
IF Allowdn% = 1 THEN ' Yes, DOWN is ok
Ek% = 3
END IF
CASE 32 ' ALT+D (Delete)
St$ = STRING$(il%, 32)
Xoff% = 1
CASE ELSE
END SELECT
END IF
IF Ek% <> 0 THEN
Nv# = VAL(St$)
IF Nv# > MaxV# OR Nv# < MinV# THEN
Ek% = 0
END IF
END IF
WEND
END SUB